home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 5 / Apprentice-Release5.iso / Environments / Yerk 3.6.8 / System source / Menu < prev    next >
Encoding:
Text File  |  1995-11-24  |  8.4 KB  |  249 lines  |  [TEXT/YERK]
  1. \  5- 7-84  NDI Version 1
  2. \  6/18/84  CBD Added Draw: and clear in MenuBar
  3. \  6/27/84  CBD Separated FILL: from INIT:
  4. \  8/16/84  CBD Non-resource definition
  5. \ 10/25/84  CBD FILL:-> PUT:, SET: -> HILITE:, etc
  6. \ 12/20/84  cbd Added desk accy support
  7. \ 12/20/84  cbd Added menu key support
  8. \ 12/30/85  cdn Expanded AppleMen to handle up to 22 items
  9. \  9/03/86  cdn Added call DrawMenuBar to enable: & disable:
  10. \  9/23/86  cdn Fixed opendesk:, saves graph port
  11. \  9/31/88    rfl    added mItem, changed mselect, key:
  12. \ 10/26/89  rfl    added menuId, more menus in mbar
  13. \                set now consistent with get,check,uncheck
  14. \                All begin with 1.
  15. \  5/13/90    rfl    added ability to add and remove menus in menubar
  16. \  5/23/90    rfl    added hmenu,pmenu,applemenu
  17. \  5/30/90    rfl modified enable, disable menubar to work nicer in display
  18. \ 12/24/90    rfl fixed getName: pmenu
  19. \  5/10/91    rfl added getnew: for use with resource files
  20. \  5/14/91    rfl    addone does not add to menubar if menu already is there
  21. \  2/25/92    rfl    added getName; checkone
  22. \  6/23/92    rfl    removed position: from pmenu; fixed uncheckall:
  23. \  7/19/92    rfl    changed set: to have stack consistent with sarray input to:
  24. \ 11/10/92    rfl changed 'getname: pmenu' to getHItemName, so can use super method
  25. \ 12/21/92    rfl    added ability to determine if an item is checked with checked?: method
  26. \  5/25/93    rfl added remove: to release: and dispose:; release: to getnew: applemen
  27. \  8/04/93    rfl    getText: pmenu now agrees with lastpick (start from 1, not zero) **change propagates
  28. \ 12/27/93    rfl    fixed getnew: applemen to behave better on multiple getnew:
  29. \  9/24/94    rfl    removed pmenu from this source. Now a separate source for system 6.
  30. \                PopUp support for system 7 is in separate source also.
  31. \ 11/01/94    rfl    added indexOf: menu to search for text item; delete: also
  32. \  3/28/95    rfl    added insertItem
  33. \ 11/23/95    rfl    changed get: to put text into buf255+80, so that indexof: will work with " "
  34.  
  35. \ ( hndl -- )  error if Toolbox object hasn't called new: or getnew:
  36. : ?new   dup 0= classerr" 153 ;
  37.  
  38. 0 value theMenu    \ the pointer to the selected menu
  39.  
  40. :CLASS Menu  <Super X-Array
  41.  
  42.     Int        Resid    \ Resource ID of this menu
  43.     handle    Mhndl    \ Handle to menu heap storage
  44.  
  45.     \ ( -- resid )
  46.     :M  ID:      Get: Resid     ;M
  47.  
  48.     \ ( resID -- )  store menuID
  49.     :M  INIT:  put: resID  ;M
  50.  
  51.     :M  PUTRESID: put: resID ;M
  52.  
  53.     \ ( cfa0...cfaN resid -- )  put resid and handlers in menu
  54.     :M  PUT:     Put: ResId   Put: Super  ;M
  55.  
  56.     \ ( item# -- addr len )  get string for item #
  57.     :M  GET:  { item \ addr -- addr len } buf255 $ 80 + -> addr
  58.         get: mhndl item makeInt
  59.         addr +base  call GetItem  addr count ;M
  60.  
  61.     :M  GETNAME: ( -- addr len) get: Mhndl >ptr 14 + count ;M
  62.  
  63.     :M  GETNEW: 0 int: ResId call getMenu dup 0= ?error 161 put: mHndl ;M
  64.  
  65.     \ ( addr len -- )  Allocate menu with  Title
  66.     :M  NEW:  str255  >R 0  Int: resId  R> call NewMenu
  67.         Put: Mhndl    ;M
  68.  
  69.     :M  REMOVE: int: resId call deleteMenu ;M
  70.  
  71.     \ ( -- )  Insert the menu in the menu bar
  72.     :M  INSERT:   Get: Mhndl ?new word0 call InsertMenu  ;M
  73.  
  74.     \ use this is menu was not read in from a resource file
  75.     :M  DISPOSE: remove: self get: mHndl call disposMenu clear: mHndl ;M
  76.  
  77.     \ use this if menu read in from resource file instead of dispose:
  78.     :M  RELEASE: remove: self get: mHndl call ReleaseResource clear: mHndl ;M
  79.  
  80.     \ ( addr len -- )  Append a menu item
  81.     :M  ADD:   Str255  Get:  Mhndl ?new
  82.         swap  call AppendMenu  ;M
  83.  
  84.     :M INSERTITEM: ( addr len item --) >r str255 get: mHndl swap r> makeint call insMenuItem ;M
  85.  
  86.     \ ( item --) delete a menu item
  87.     :M DELETE: get: mHndl swap makeint call DelMenuItem ;M
  88.  
  89.     \ ( type -- )  add all resources of a type
  90.     :M  ADDRES:  get: mhndl swap call AddResMenu  ;M
  91.  
  92.     \ ( addr len item# -- )  replace menu item string
  93.     :M  SET:   >r str255 >r get: mhndl ?new
  94.         r> r> swap >r makeInt r> call SetItem ;M
  95.  
  96.     \ ( -- )  Remove hiliting on all items
  97.     :M  NORMAL:  word0  call HiliteMenu ;M
  98.  
  99.     :M  HILITE: int: resID call hiliteMenu ;M
  100.  
  101.     \ ( item# -- )  Enable a menu item
  102.     :M  ENABLE:  Get: Mhndl over makeInt call EnableItem
  103.         0= IF call DrawMenuBar THEN  ;M
  104.  
  105.     \ ( item# -- )  Grey and disable an item
  106.     :M  DISABLE: Get: Mhndl over makeInt call DisableItem
  107.         0= IF call DrawMenuBar THEN  ;M
  108.  
  109.  
  110.     \ ( item# -- )  open the desk accy for item#
  111.     :M  OPENDESK: savePort get: self 2drop
  112.         word0 buf255 $ 80 + +base call OpenDeskAcc word0 drop restPort  ;M
  113.  
  114.     \ all menu handlers will have item# on stack when they execute
  115.     \ ( item# -- )  Execute the code for a menu item
  116.     :M  EXEC: ^base -> theMenu 1- dup Exec: Super drop  Normal: Self   ;M
  117.  
  118.     \ ( item# -- )
  119.     :M  CHECK:  Get: Mhndl  swap makeInt w 256 call CheckItem  ;M
  120.  
  121.     \ ( item# -- )
  122.     :M  UNCHECK:     Get: Mhndl  swap makeInt word0 call CheckItem  ;M
  123.  
  124.     :M UNCHECKALL: limit 1+ 1 DO i uncheck: self LOOP ;M
  125.     :M CHECKONE: ( n --) uncheckall: self check: self ;M
  126.  
  127.     :M CHECKED?: { mitem \ addr -- b }
  128.         mitem limit > classerr" 129                \ make sure within limits
  129.         get: mhndl >ptr 14 + -> addr            \ move to title field in record
  130.         addr c@ addr + 1+ -> addr                \ move to 1st item pascal string
  131.         mitem 0                                    \ start search for end of mitem string
  132.         DO addr c@ addr + 1+ 4+ -> addr LOOP    \ moves to end of mitem string
  133.         addr 2- c@ 0= IF false ELSE true THEN ;M    \ moves back to check byte
  134.  
  135. \ return the number of items in the menu
  136.     :M MITEMS: word0 get: MHndl call countMItems i->l ;M
  137.  
  138. \ will work only if addr len is not in buf255!!
  139.     :M INDEXOF: { addr len \ flag -- item t | f } false -> flag
  140.         mitems: self 1+ 1 DO i get: self addr len s= IF i true -> flag LEAVE THEN LOOP
  141.         flag ;M
  142.  
  143. ;CLASS
  144.  
  145. :CLASS applemenu <super menu
  146.  
  147.     :M  EXEC: ( item# --) dup 3 <
  148.             IF exec: super ELSE openDesk: super normal: super THEN ;M
  149.  
  150. \ there is a problem when getnew: applemen is done more than once in an application
  151. \  the DRVR resources are added again and again, making the menu really big and
  152. \  repetative. To protect against this, check to see if there are more items
  153. \  in the menu than the limit of the menu object. If so, the it's ok to add the drvrs.
  154.     :M  GETNEW: getnew: super mitems: self limit <=
  155.             IF 'type DRVR  addRes: self THEN ;M
  156.  
  157. ;CLASS
  158.  
  159.  
  160. :CLASS hmenu <super menu
  161.  :M insert: get: mhndl w -1 call insertMenu ( ^base addone: menubar) ;M
  162. ;CLASS
  163.  
  164. 0 value mItem    \ global keeping # of last menu item clicked;start1
  165. 0 value menuID
  166.  
  167. \ ( point -- item# menuID )  call menu manager to track a menu selection
  168. : Mselect 0 swap call MenuSelect unpack swap dup -> mItem swap 
  169.      -> menuID menuID  ;
  170.  
  171.  
  172. \ 3.11.90    rfl    modified getText: for popUps to support hierarchical. Get: still works
  173. \  The print method for popUpRect always look to the stringvar for printing.
  174. \ it is loaded to the correct string on menu select by the mode value.
  175.  
  176.  
  177. \ ( item# -- item#)  execute the desk accessory for an item
  178. \ : doDsk  1+ dup openDesk: [ ^base ]  ;
  179.  
  180. 2 applemenu applemen
  181.  
  182.  
  183. :CLASS mBar  <Super Object
  184.  
  185.     26 wordcol    IDs
  186.     26 ordered-col    Menus    \ array of menu objects
  187.  
  188.     \ ( -- )
  189.     :M  DRAW:   call DrawMenuBar     ;M
  190.  
  191.     \ ( -- )
  192.     :M  CLEAR:   call ClearMenuBar  Clear: IDs clear: Menus   ;M
  193.  
  194.     :M  Menu: ( id -- menu t or f) indexof: ids IF at: menus true ELSE false THEN ;M
  195.  
  196.     :M  addone: ( ^menu -- ) dup indexof: Menus not
  197.         IF id: [ dup ] add: ids dup add: menus insert: [ ] draw: self
  198.         ELSE 2drop
  199.         THEN ;M
  200.  
  201.     :M  remove: ( ^menu -- ) remove: [ dup ] indexof: menus
  202.         IF dup remove: menus remove: ids THEN draw: self ;M
  203.  
  204.     \ Add menu objects in stream to the MenuBar object
  205.     \ ( ^men0...^menN  #menus -- )
  206.     :M  ADD:  0
  207.         DO   add: Menus  Id: [ I at: menus ]  Add: IDs
  208.         LOOP  ;M
  209.  
  210.     \ ( -- )  Insert menus in Toolbox MenuBar list
  211.     :M  NEW:    Size: IDs  0
  212.         DO  insert: [ Size: IDs  1- i-  at: Menus ]
  213.         LOOP  Draw: Self   ;M
  214.  
  215.     :M  GETNEW: size: Menus 0 DO getnew: [ i at: Menus ] LOOP ;M
  216.  
  217.     \ ( men0...menN #menus -- )
  218.     :M  INIT:  Clear: self  Add: Self  getnew: self New: self   ;M
  219.  
  220.     \ ( men0...menN #menus -- ) - use with mload module
  221. \    :M  MINIT:  Clear: self  Add: Self  New: self   ;M
  222.  
  223.     \ ( item# MenuID -- )
  224.     :M  EXEC:  dup 0>
  225.         IF   IndexOf:  IDs
  226.             IF  Exec: [ at: Menus ]  THEN
  227.         ELSE  2drop
  228.         THEN   ;M    \ Execute item in menu
  229.  
  230.     \ ( -- )
  231.     :M  CLICK:  Where: fEvent   MSelect  Exec: Self   ;M
  232.  
  233.     \ ( chr -- )   handle a possible menu key selection
  234.     :M  KEY:  0 swap makeInt call MenuKey unpack -> menuID -> mItem
  235.         mItem menuID exec: self   ;M
  236.     
  237.     \ Enable all menus in the Menu Bar
  238.     :M  ENABLE:   Size: IDs 0
  239.         DO I at: menus 2+ @ word0 call enableItem LOOP Draw: Self   ;M
  240.  
  241.     :M  DISABLE:  Size: IDs 0
  242.         DO  i at: Menus 2+ @ word0 call disableItem  LOOP  Draw: Self  ;M
  243.  
  244. ;CLASS
  245.  
  246. \  Define the default menu bar for applications
  247.  mBar MenuBar
  248.  
  249.